home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / topo.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  16.8 KB  |  516 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C Module name: TopDraw
  4.  
  5. C Author: Toby Howard
  6.  
  7. C Function: Implements the PHIGS structure network topology drawing tool.
  8.  
  9. C External function list: ptk_topology.
  10.  
  11. C Internal function list:
  12.  
  13. C Hashtables used: "structureid", "name", "label".
  14.  
  15. C Modification history: (Version), (Date), (Name), (Description).
  16.  
  17. C 1.0, ????, Toby Howard, First version.
  18.  
  19. C 1.1, 29th July 1988, Steve Larkin, Modified to use Vax Phigs instead of 
  20. C KRT3.
  21.  
  22. C 2.0, 10th June 1991, Gareth Williams, Translated to C.
  23.  
  24. C----------------------------------------------------------------------------
  25.  
  26.        SUBROUTINE ptkf_createtopology(topid, root, error)
  27. C /* 
  28. C ** \parambegin
  29. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  30. C ** \param{INTEGER}{root}{structure network identifier}{IN}
  31. C ** \param{INTEGER}{error}{error code}{OUT}
  32. C ** \paramend
  33. C ** \blurb{This function creates a diagram of the structure network
  34. C ** specified by {\tt root}. The diagram is a PHIGS structure which
  35. C ** uses boxes connected by lines to represent structures and
  36. C ** EXECUTE STRUCTURE elements. The error code = 1 if the root structure
  37. C ** does not exist.} 
  38. C */
  39.        INTEGER topid, root, error
  40.        external ptk_createtopology !$PRAGMA C(ptk_createtopology)
  41.  
  42.        call ptk_createtopology(%val(topid), %val(root), error)
  43.  
  44.        RETURN
  45.        END
  46.  
  47.        SUBROUTINE ptkf_settopologyattrs(topid, txfont, linecol, 
  48. & textcol, edgecol, intcol, htedgecol, htintcol)
  49. C /* 
  50. C ** \parambegin
  51. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  52. C ** \param{INTEGER}{txfont}{label text font}{IN}
  53. C ** \param{INTEGER}{linecol}{polyline colour index}{IN}
  54. C ** \param{INTEGER}{textcol}{text colour index}{IN}
  55. C ** \param{INTEGER}{edgecol}{edge colour index}{IN}
  56. C ** \param{INTEGER}{intcol}{interior colour index}{IN}
  57. C ** \param{INTEGER}{htedgecol}{highlight edge colour index}{IN}
  58. C ** \param{INTEGER}{htintcol}{highlight interior colour index}{IN}
  59. C ** \paramend
  60. C ** \blurb{This function sets the text font and colour attribute values 
  61. C ** of a topology diagram. The text font applies to the structure
  62. C ** names which are extracted from the \"structureid\" hashtable.
  63. C ** The highlight colour indicies are used to highlight a single
  64. C ** topology node in the function {\tt ptk\_settopologyhighlightnode}.}
  65. C */
  66.        INTEGER topid, txfont, linecol
  67.        INTEGER textcol, edgecol, intcol, htedgecol, htintcol
  68.        external ptk_settopologyattrs !$PRAGMA C(ptk_settopologyattrs)
  69.  
  70.        call ptk_settopologyattrs(%val(topid), %val(txfont), 
  71. & %val(linecol), %val(textcol), %val(edgecol), %val(intcol), 
  72. & %val(htedgecol), %val(htintcol))
  73.  
  74.        RETURN
  75.        END
  76.  
  77.        SUBROUTINE ptkf_inqtopologyattrs(topid, txfont, linecol, 
  78. & textcol, edgecol, intcol, htedgecol, htintcol, err)
  79. C /* 
  80. C ** \parambegin
  81. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  82. C ** \param{INTEGER}{txfont}{label text font}{OUT}
  83. C ** \param{INTEGER}{linecol}{polyline colour index}{OUT}
  84. C ** \param{INTEGER}{textcol}{text colour index}{OUT}
  85. C ** \param{INTEGER}{edgecol}{edge colour index}{OUT}
  86. C ** \param{INTEGER}{intcol}{interior colour index}{OUT}
  87. C ** \param{INTEGER}{htedgecol}{highlight edge colour index}{OUT}
  88. C ** \param{INTEGER}{htintcol}{highlight interior colour index}{OUT}
  89. C ** \param{INTEGER}{err}{error indicator}{OUT}
  90. C ** \paramend
  91. C ** \blurb{This function may be used to obtain the text font and
  92. C ** colour attribute values of a topology diagram.}
  93. C */
  94.        INTEGER topid, txfont, linecol
  95.        INTEGER textcol, edgecol, intcol, htedgecol, htintcol, err
  96.        external ptk_inqtopologyattrs !$PRAGMA C(ptk_inqtopologyattrs)
  97.  
  98.        call ptk_inqtopologyattrs(%val(topid), txfont, linecol, 
  99. & textcol, edgecol, intcol, htedgecol, htintcol, err)
  100.  
  101.        RETURN
  102.        END
  103.  
  104.        SUBROUTINE ptkf_settopologytype(topid, toptype)
  105. C /*
  106. C ** \parambegin
  107. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  108. C ** \param{INTEGER}{toptype}{topology type}{IN}
  109. C ** \paramend
  110. C ** \blurb{This function sets the type of a topology diagram to 
  111. C ** BOX, STRUCT or STRUCTNET. The BOX topology type is the default and
  112. C ** the STRUCT and STRUCTNET types insert parts of the actual structures
  113. C ** into the nodes. As a result these topology types do not work well
  114. C ** for networks containing SET VIEW INDEX and SET GLOBAL TRANSFORMATION
  115. C ** elements.}
  116. C */
  117.        INTEGER topid, toptype
  118.        external ptk_settopologytype !$PRAGMA C(ptk_settopologytype)
  119.  
  120.        call ptk_settopologytype(%val(topid), %val(toptype))
  121.  
  122.        RETURN
  123.        END
  124.  
  125.        SUBROUTINE ptkf_inqtopologytype(topid, toptype, err)
  126. C /*
  127. C ** \parambegin
  128. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  129. C ** \param{INTEGER}{toptype}{topology type}{OUT}
  130. C ** \param{INTEGER}{err}{error indicator}{OUT}
  131. C ** \paramend
  132. C ** \blurb{This function may be used to obtain the type of a topology
  133. C ** diagram. The possible types are BOX, STRUCT and STRUCTNET, with BOX
  134. C ** as the default.}
  135. C */
  136.        INTEGER topid, toptype, err
  137.        external ptk_inqtopologytype !$PRAGMA C(ptk_inqtopologytype)
  138.  
  139.        call ptk_inqtopologytype(%val(topid), toptype, err)
  140.  
  141.        RETURN
  142.        END
  143.  
  144.        SUBROUTINE ptkf_setnodeposition(topid, structid, nodept, 
  145. & nodetype)
  146. C /*
  147. C ** \parambegin
  148. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  149. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  150. C ** \param{REAL}{nodept(2)}{node position}{IN}
  151. C ** \param{INTEGER}{nodetype}{type of node}{IN}
  152. C ** \paramend
  153. C ** \blurb{This function sets the position of a topology node or group
  154. C ** of nodes. The position is given in the range [0, 1].
  155. C ** The node is specified using the structure identifier of the structure
  156. C ** that it represents. If nodetype is set to GROUP then all descendent
  157. C ** nodes of {\tt structid} are moved relative to it.}
  158. C */
  159.        INTEGER topid, structid
  160.        REAL nodept(3)
  161.        INTEGER nodetype
  162.        external ptk_setnodeposition !$PRAGMA C(ptk_setnodeposition)
  163.  
  164.        call ptk_setnodeposition(%val(topid), %val(structid), 
  165. & nodept, %val(nodetype))
  166.  
  167.        RETURN
  168.        END
  169.  
  170.        SUBROUTINE ptkf_inqnodeposition(topid, structid, nodept, err)
  171. C /*
  172. C ** \parambegin
  173. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  174. C ** \param{INTEGER}{structid}{structure identifier}{IN}
  175. C ** \param{REAL}{nodept(2)}{node position}{OUT}
  176. C ** \param{INTEGER}{err}{error indicator}{OUT}
  177. C ** \paramend
  178. C ** \blurb{This function may be used to obtain the position of a topology 
  179. C ** node in a topology diagram. The position is returned in the 
  180. C ** range [0, 1]. The node is specified using the structure
  181. C ** identifier of the structure that it represents.}
  182. C */
  183.        INTEGER topid, structid
  184.        REAL nodept(3)
  185.        INTEGER err
  186.        external ptk_inqnodeposition !$PRAGMA C(ptk_inqnodeposition)
  187.  
  188.        call ptk_inqnodeposition(%val(topid), %val(structid), 
  189. & nodept, err)
  190.  
  191.        RETURN
  192.        END
  193.  
  194.        SUBROUTINE ptkf_tidytopology(wsid, topid, nodetype, pickdev, 
  195. & pickpet, pldr, pdatrec, locdev, locpet, lldr, ldatrec)
  196. C /*
  197. C ** \parambegin
  198. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  199. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  200. C ** \param{INTEGER}{nodetype}{type of node}{IN}
  201. C ** \param{INTEGER}{pickdev}{pick device}{IN}
  202. C ** \param{INTEGER}{pickpet}{pick prompt/echo type}{IN}
  203. C ** \param{INTEGER}{pldr}{size of record array}{IN}
  204. C ** \param{CHARACTER*80}{pdatarec(*)}{pick data record}{IN}
  205. C ** \param{INTEGER}{locdev}{locator device}{IN}
  206. C ** \param{INTEGER}{locpet}{locator prompt/echo type}{IN}
  207. C ** \param{INTEGER}{lldr}{size of record array}{IN}
  208. C ** \param{CHARACTER*80}{locdatarec(*)}{locator data record}{IN}
  209. C ** \paramend
  210. C ** \blurb{This function enables the user to set the position of
  211. C ** a topology node, or group of nodes, interactively. The pick device
  212. C ** {\tt pickdev} is used to request a topology node and if
  213. C ** successful the locator device {\tt locdev} is used to specify
  214. C ** a new node position. Prompt and echo types may be set for both
  215. C ** the pick and locator devices.}
  216. C */
  217.        INTEGER wsid, topid, nodetype, pickdev, pickpet, pldr
  218.        CHARACTER*80 pdatrec(pldr)
  219.        INTEGER locdev, locpet, lldr
  220.        CHARACTER*80 ldatrec(lldr)
  221.        INTEGER nodeid
  222.        REAL point(3)
  223.        INTEGER incl(10), excl(10)
  224.        INTEGER i, err
  225.        LOGICAL found
  226.        REAL echo(6)
  227.        REAL maxdevx, maxdevy, maxdevz
  228.        INTEGER topname, topstid
  229.        INTEGER pp(3, 10), ppath(3, 10)
  230.        INTEGER stat, ppd
  231.  
  232.        include './sunphigs77.h'
  233.        include './sunptk77.h'
  234.  
  235.        implicit undefined (P, p, E, e)
  236.  
  237.        call ptkf_inqtopologyname(topid, topname, err)
  238.  
  239.        call ptkf_inqtopologystructid(topid, topstid, err)
  240.        call ptkf_inqmaxdevicecoords3(wsid, maxdevx, maxdevy, maxdevz)
  241.        call ptkf_limit3(0.0, maxdevx, 0.0, maxdevy, 0.0, maxdevz, echo)
  242.  
  243. C  pick topology node 
  244.    
  245.        call pspkm(wsid, pickdev, PREQU, PECHO)
  246.        call pinpk3(wsid, pickdev, PNPICK, 0, pp, pickpet, echo, 
  247. & pldr, pdatrec, PPOBOT) 
  248.  
  249.        incl(1) = topname
  250.        call pspkft(wsid, pickdev, 1, incl, 0, excl)
  251.  
  252.        call prqpk(wsid, pickdev, 10, stat, ppd, ppath)
  253.  
  254.        if (stat .ne. POK) then
  255.          RETURN
  256.        endif
  257.  
  258. C  find picked node 
  259.        i = 0
  260.        found = .FALSE.
  261.  10    if (found .ne. .TRUE. .and. i .lt. 10) then 
  262.          if (ppath(1, i) .eq. topstid) then
  263.            nodeid = ppath(2, i)
  264.            found = .TRUE.
  265.            goto 20
  266.          endif
  267.          i = i + 1
  268.          goto 10
  269.        endif
  270.  
  271. C  locate point
  272.  20    call pinlc3(wsid, locdev, 0, 0.5, 0.5, 0.0, locpet, echo,
  273. & lldr, ldatrec)
  274.        call pslcm(wsid, locdev, PREQU, PECHO)
  275.        call prqlc3(wsid, locdev, stat, view, point(1), point(2), 
  276. & point(3))
  277.  
  278.        if (stat .ne. POK) then
  279.          RETURN
  280.        endif
  281.        
  282.        call ptkf_setnodeposition(topid, nodeid, point, nodetype)
  283.  
  284.        RETURN
  285.        END
  286.  
  287.        SUBROUTINE ptkf_posttopology(wsid, topid, priority)
  288. C /*
  289. C ** \parambegin
  290. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  291. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  292. C ** \param{REAL}{priority}{display priority}{IN}
  293. C ** \paramend
  294. C ** \blurb{This function posts a topology diagram structure to the
  295. C ** workstation {\tt wsid}.}
  296. C */ 
  297.        INTEGER wsid, topid
  298.        REAL priority
  299.        REAL*8 dppriority
  300.        external ptk_posttopology !$PRAGMA C(ptk_posttopology)
  301.  
  302.        dppriority = priority
  303.        call ptk_posttopology(%val(wsid), %val(topid), %val(dppriority))
  304.  
  305.        RETURN
  306.        END
  307.  
  308.        SUBROUTINE ptkf_unposttopology(wsid, topid)
  309. C /*
  310. C ** \parambegin
  311. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  312. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  313. C ** \paramend
  314. C ** \blurb{This function unposts the topology diagram structure from
  315. C ** the workstation {\tt wsid}.}
  316. C */
  317.        INTEGER wsid, topid
  318.        external ptk_unposttopology !$PRAGMA C(ptk_unposttopology)
  319.  
  320.        call ptk_unposttopology(%val(wsid), %val(topid))
  321.  
  322.        RETURN
  323.        END
  324.  
  325.        LOGICAL FUNCTION ptkf_deltopology(topid)
  326. C /*
  327. C ** \parambegin
  328. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  329. C ** \paramend
  330. C ** \blurb{This function deletes a topology diagram from the PHIGS Toolkit
  331. C ** topology store. The function returns TRUE if a topology is deleted, 
  332. C ** otherwise FALSE.}
  333. C */
  334.        INTEGER topid
  335.        LOGICAL*1 ptk_deltopology, ans
  336.        external ptk_deltopology !$PRAGMA C(ptk_deltopology)
  337.  
  338.        ans = ptk_deltopology(%val(topid))
  339.        if (ans .eq. 1) then
  340.           ptkf_deltopology = .TRUE.
  341.        else
  342.           ptkf_deltopology = .FALSE.
  343.        endif
  344.  
  345.        RETURN
  346.        END
  347.  
  348.        SUBROUTINE ptkf_storetopologylayout(fileptr, topid)
  349. C /*
  350. C ** \parambegin
  351. C ** \param{INTEGER}{fileptr}{pointer to file}{OUT}
  352. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  353. C ** \paramend
  354. C ** \blurb{This function saves a topology layout in a text file. The
  355. C ** layout refers to the positions of all the topology nodes. The
  356. C ** format of the stored layout is:
  357. C ** 
  358. C ** {\tt start}
  359. C ** {\tt (for each node in topology diagram)}
  360. C ** {\tt x y}
  361. C ** {\tt end}
  362. C ** }
  363. C */
  364.        INTEGER fileptr, topid
  365.        external ptk_storetopologylayout 
  366. & !$PRAGMA C(ptk_storetopologylayout)
  367.  
  368.        call ptk_storetopologylayout(%val(fileptr), %val(topid))
  369.  
  370.        RETURN
  371.        END
  372.  
  373.        SUBROUTINE ptkf_restoretopologylayout(fileptr, topid)
  374. C /*
  375. C ** \parambegin
  376. C ** \param{INTEGER}{fileptr}{pointer to file}{OUT}
  377. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  378. C ** \paramend
  379. C ** \blurb{This function reads a topology layout from a text file.
  380. C ** The layout is used to reposition the nodes of the topology
  381. C ** diagram {\tt topid} but will only really make sense if the layout
  382. C ** was stored originally from the same topology.} 
  383. C */
  384.        INTEGER fileptr, topid
  385.        external ptk_restoretopologylayout
  386. & !$PRAGMA C(ptk_restoretopologylayout)
  387.  
  388.        call ptk_restoretopologylayout(%val(fileptr), %val(topid))
  389.  
  390.        RETURN
  391.        END
  392.  
  393.        SUBROUTINE ptkf_inqpostedtopologies(wsid, num, topids, totalnum,
  394. & err)
  395. C /*
  396. C ** \parambegin
  397. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  398. C ** \param{INTEGER}{size}{size of buffer}{IN}
  399. C ** \param{INTEGER}{topids(*)}{list of posted topologies}{OUT}
  400. C ** \param{INTEGER}{totalsize}{length of posted topologies list}{OUT}
  401. C ** \param{INTEGER}{err}{error indicator}{OUT}
  402. C ** \paramend
  403. C ** \blurb{This function may be used to obtain a list of all the
  404. C ** topology diagrams which are posted to the workstation {\tt wsid}.}
  405. C */
  406.        INTEGER wsid, num, topids(num), totalnum, err
  407.        external ptkc_inqpostedtopologies 
  408. & !$PRAGMA C(ptkc_inqpostedtopologies)
  409.  
  410.        call ptkc_inqpostedtopologies(%val(wsid), %val(num), topids, 
  411. & totalsize, err)
  412.  
  413.        RETURN
  414.        END
  415.  
  416.        SUBROUTINE ptkf_inqtopologyids(num, topids, totalnum, err)
  417. C /*
  418. C ** \parambegin
  419. C ** \param{INTEGER}{size}{size of buffer}{IN}
  420. C ** \param{INTEGER}{topids(*)}{list of topology identifiers}{OUT}
  421. C ** \param{INTEGER}{totalsize}{length of topology identifiers list}{OUT}
  422. C ** \param{INTEGER}{err}{error indicator}{OUT}
  423. C ** \paramend
  424. C ** \blurb{This function may be used to obtain a list of all the topology
  425. C ** diagrams in the PHIGS Toolkit topology store.}
  426. C */
  427.        INTEGER num, topids, totalnum, err
  428.        external ptkc_inqtopologyids !$PRAGMA C(ptkc_inqtopologyids)
  429.  
  430.        call ptkc_inqtopologyids(%val(num), topids, totalnum, err)
  431.  
  432.        RETURN
  433.        END
  434.  
  435.        SUBROUTINE ptkf_inqtopologystructid(topid, topstid, err)
  436. C /*
  437. C ** \parambegin
  438. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  439. C ** \param{INTEGER}{topstid}{topology structure identifier}{IN}
  440. C ** \param{INTEGER}{err}{error indicator}{OUT}
  441. C ** \paramend
  442. C ** \blurb{This function may be used to obtain the structure identifier 
  443. C ** of the topology diagram {\tt topid}. In the case of the BOX topology
  444. C ** type the diagram is a single PHIGS structure but for STRUCT and
  445. C ** STRUCTNET type diagrams it is a structure network.}
  446. C */
  447.        INTEGER topid, topstid, err
  448.        external ptk_inqtopologystructid
  449. & !$PRAGMA C(ptk_inqtopologystructid)
  450.  
  451.        call ptk_inqtopologystructid(%val(topid), topstid, err)
  452.  
  453.        RETURN
  454.        END
  455.  
  456.        SUBROUTINE ptkf_inqtopologyname(topid, topname, err)
  457. C /*
  458. C ** \parambegin
  459. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  460. C ** \param{INTEGER}{name}{topology name for nameset filters}{OUT}
  461. C ** \param{INTEGER}{err}{error indicator}{OUT}
  462. C ** \paramend
  463. C ** \blurb{This function may be used to obtain the topology name for use 
  464. C ** in the pick filter. When a topology name is added to the pick filter
  465. C ** only the topology nodes are pickable.}
  466. C */
  467.        INTEGER topid, topname, err
  468.        external ptk_inqtopologyname !$PRAGMA C(ptk_inqtopologyname)
  469.  
  470.        call ptk_inqtopologyname(%val(topid), topname, err)
  471.  
  472.        RETURN
  473.        END
  474.  
  475.        SUBROUTINE ptkf_settopologyhighlightnode(topid, topnodestid)
  476. C /*
  477. C ** \parambegin
  478. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  479. C ** \param{INTEGER}{topnodestid}{topology node structure identifier}{IN}
  480. C ** \paramend
  481. C ** \blurb{This function highlights a single topology node by
  482. C ** setting the colour attribute values of the edge and interior of
  483. C ** the node box. This function only works for BOX topology types.}
  484. C */
  485.        INTEGER topid, topnodestid
  486.        external ptk_settopologyhighlightnode 
  487. & !$PRAGMA C(ptk_settopologyhighlightnode)
  488.  
  489.        call ptk_settopologyhighlightnode(%val(topid), %val(topnodestid))
  490.  
  491.        RETURN
  492.        END
  493.  
  494.        SUBROUTINE ptkf_inqtopologyhighlightnode(topid, topnodestid,
  495. & err)
  496. C /*
  497. C ** \parambegin
  498. C ** \param{INTEGER}{topid}{topology identifier}{IN}
  499. C ** \param{INTEGER}{topnodestid}{topology node structure identifier}{OUT}
  500. C ** \param{INTEGER}{err}{error indicator}{OUT}
  501. C ** \paramend
  502. C ** \blurb{This function may be used to obtain the structure
  503. C ** identifier of the currently highlighted topology node.}
  504. C */
  505.        INTEGER topid, topnodestid, err
  506.        external ptk_inqtopologyhighlightnode 
  507. & !$PRAGMA C(ptk_inqtopologyhighlightnode)
  508.  
  509.        call ptk_inqtopologyhighlightnode(%val(topid), topnodestid,
  510. & err)
  511.  
  512.        RETURN
  513.        END
  514.  
  515. C end of topo.f
  516.